home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / akcl / kcl.lha / h / cmpinclude.h < prev    next >
C/C++ Source or Header  |  1987-06-04  |  10KB  |  469 lines
  1. /*
  2. (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  3. Copying of this file is authorized to users who have executed the true and
  4. proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  5. */
  6. #include <stdio.h>
  7. #include <setjmp.h>
  8. #define    TRUE    1
  9. #define    FALSE    0
  10. typedef int bool;
  11. typedef int fixnum;
  12. typedef float shortfloat;
  13. typedef double longfloat;
  14. typedef union lispunion *object;
  15. #define    OBJNULL    ((object)NULL)
  16. struct fixnum_struct {
  17.     short    t, m;
  18.     fixnum    FIXVAL;
  19. };
  20. #define    fix(x)    (x)->FIX.FIXVAL
  21. #define    SMALL_FIXNUM_LIMIT    1024
  22. struct fixnum_struct small_fixnum_table[];
  23. #define    small_fixnum(i)    (object)(small_fixnum_table+SMALL_FIXNUM_LIMIT+(i))
  24. struct shortfloat_struct {
  25.     short        t, m;
  26.     shortfloat    SFVAL;
  27. };
  28. #define    sf(x)    (x)->SF.SFVAL
  29. struct longfloat_struct {
  30.     short        t, m;
  31.     longfloat    LFVAL;
  32. };
  33. #define    lf(x)    (x)->LF.LFVAL
  34. struct character {
  35.     short        t, m;
  36.     unsigned short    ch_code;
  37.     unsigned char    ch_font;
  38.     unsigned char    ch_bits;
  39. };
  40. struct character character_table[];
  41. #define    code_char(c)    (object)(character_table+(c))
  42. #define    char_code(x)    (x)->ch.ch_code
  43. #define    char_font(x)    (x)->ch.ch_font
  44. #define    char_bits(x)    (x)->ch.ch_bits
  45. enum stype {
  46.     stp_ordinary,
  47.     stp_constant,
  48.         stp_special
  49. };
  50. struct symbol {
  51.     short    t, m;
  52.     object    s_dbind;
  53.     int    (*s_sfdef)();
  54. #define    s_fillp        st_fillp
  55. #define    s_self        st_self
  56.     int    s_fillp;
  57.     char    *s_self;
  58.     object    s_gfdef;
  59.     object    s_plist;
  60.     object    s_hpack;
  61.     short    s_stype;
  62.     short    s_mflag;
  63. };
  64. struct cons {
  65.     short    t, m;
  66.     object    c_cdr;
  67.     object    c_car;
  68. };
  69. struct array {
  70.     short    t, m;
  71.     short    a_rank;
  72.     short    a_adjustable;
  73.     int    a_dim;
  74.     int    *a_dims;
  75.     object    *a_self;
  76.     object    a_displaced;
  77.     short    a_elttype;
  78.     short    a_offset;
  79. };
  80. struct vector {
  81.     short    t, m;
  82.     short    v_hasfillp;
  83.     short    v_adjustable;
  84.     int    v_dim;
  85.     int    v_fillp;
  86.     object    *v_self;
  87.     object    v_displaced;
  88.     short    v_elttype;
  89.     short    v_offset;
  90. };
  91. struct string {
  92.     short    t, m;
  93.     short    st_hasfillp;
  94.     short    st_adjustable;
  95.     int    st_dim;
  96.     int    st_fillp;
  97.     char    *st_self;
  98.     object    st_displaced;
  99. };
  100. struct ustring {
  101.     short    t, m;
  102.     short    ust_hasfillp;
  103.     short    ust_adjustable;
  104.     int    ust_dim;
  105.     int    ust_fillp;
  106.     unsigned char
  107.         *ust_self;
  108.     object    ust_displaced;
  109. };
  110. struct bitvector {
  111.     short    t, m;
  112.     short    bv_hasfillp;
  113.     short    bv_adjustable;
  114.     int    bv_dim;
  115.     int    bv_fillp;
  116.     char    *bv_self;
  117.     object    bv_displaced;
  118.     short    bv_elttype;
  119.     short    bv_offset;
  120. };
  121. struct fixarray {
  122.     short    t, m;
  123.     short    fixa_rank;
  124.     short    fixa_adjustable;
  125.     int    fixa_dim;
  126.     int    *fixa_dims;
  127.     fixnum    *fixa_self;
  128.     object    fixa_displaced;
  129.     short    fixa_elttype;
  130.     short    fixa_offset;
  131. };
  132. struct sfarray {
  133.     short    t, m;
  134.     short    sfa_rank;
  135.     short    sfa_adjustable;
  136.     int    sfa_dim;
  137.     int    *sfa_dims;
  138.     shortfloat
  139.         *sfa_self;
  140.     object    sfa_displaced;
  141.     short    sfa_elttype;
  142.     short    sfa_offset;
  143. };
  144. struct lfarray {
  145.     short    t, m;
  146.     short    lfa_rank;
  147.     short    lfa_adjustable;
  148.     int    lfa_dim;
  149.     int    *lfa_dims;
  150.     longfloat
  151.         *lfa_self;
  152.     object    lfa_displaced;
  153.     short    lfa_elttype;
  154.     short    lfa_offset;
  155. };
  156. struct structure {
  157.     short    t, m;
  158.     object    str_name;
  159.     object    *str_self;
  160.     int    str_length;
  161. };
  162. struct cfun {
  163.     short    t, m;
  164.     object    cf_name;
  165.     int    (*cf_self)();
  166.     object    cf_data;
  167.     char    *cf_start;
  168.     int    cf_size;
  169. };
  170. struct cclosure {
  171.     short    t, m;
  172.     object    cc_name;
  173.     int    (*cc_self)();
  174.     object    cc_env;
  175.     object    cc_data;
  176.     char    *cc_start;
  177.     int    cc_size;
  178.     object    *cc_turbo;
  179. };
  180. struct dummy {
  181.     short    t, m;
  182. };
  183. union lispunion {
  184.     struct fixnum_struct
  185.             FIX;
  186.     struct shortfloat_struct
  187.             SF;
  188.     struct longfloat_struct
  189.             LF;
  190.     struct character
  191.             ch;
  192.     struct symbol    s;
  193.     struct cons    c;
  194.     struct array    a;
  195.     struct vector    v;
  196.     struct string    st;
  197.     struct ustring    ust;
  198.     struct bitvector
  199.             bv;
  200.     struct structure
  201.             str;
  202.     struct cfun    cf;
  203.     struct cclosure    cc;
  204.     struct dummy    d;
  205.     struct fixarray    fixa;
  206.     struct sfarray    sfa;
  207.     struct lfarray    lfa;
  208. };
  209. enum type {
  210.     t_cons = 0,
  211.     t_start = t_cons,
  212.     t_fixnum,
  213.     t_bignum,
  214.     t_ratio,
  215.     t_shortfloat,
  216.     t_longfloat,
  217.     t_complex,
  218.     t_character,
  219.     t_symbol,
  220.     t_package,
  221.     t_hashtable,
  222.     t_array,
  223.     t_vector,
  224.     t_string,
  225.     t_bitvector,
  226.     t_structure,
  227.     t_stream,
  228.     t_random,
  229.     t_readtable,
  230.     t_pathname,
  231.     t_cfun,
  232.     t_cclosure,
  233.     t_spice,
  234.     t_end,
  235.     t_contiguous,
  236.     t_relocatable,
  237.     t_other
  238. };
  239. #define    type_of(obje)    ((enum type)(((object)(obje))->d.t))
  240. #define    endp(obje)    endp1(obje)
  241. object value_stack[];
  242. #define    vs_org        value_stack
  243. object *vs_limit;
  244. object *vs_base;
  245. object *vs_top;
  246. #define    vs_push(obje)    (*vs_top++ = (obje))
  247. #define    vs_pop        (*--vs_top)
  248. #define    vs_head        vs_top[-1]
  249. #define    vs_mark        object *old_vs_top = vs_top
  250. #define    vs_reset    vs_top = old_vs_top
  251. #define    vs_check    if (vs_top >= vs_limit)  \
  252.                 vs_overflow();
  253. #define    vs_check_push(obje)  \
  254.             (vs_top >= vs_limit ?  \
  255.              (object)vs_overflow() : (*vs_top++ = (obje)))
  256. #define    check_arg(n)  \
  257.             if (vs_top - vs_base != (n))  \
  258.                 check_arg_failed(n)
  259. #define    MMcheck_arg(n)  \
  260.             if (vs_top - vs_base < (n))  \
  261.                 too_few_arguments();  \
  262.             else if (vs_top - vs_base > (n))  \
  263.                 too_many_arguments()
  264. #define vs_reserve(x)    if(vs_base+(x) >= vs_limit)  \
  265.                 vs_overflow();
  266. struct bds_bd {
  267.     object    bds_sym;
  268.     object    bds_val;
  269. };
  270. struct bds_bd bind_stack[];
  271. #define bds_org        bind_stack
  272. typedef struct bds_bd *bds_ptr;
  273. bds_ptr bds_limit;
  274. bds_ptr bds_top;
  275. #define    bds_check  \
  276.     if (bds_top >= bds_limit)  \
  277.         bds_overflow()
  278. #define    bds_bind(sym, val)  \
  279.     ((++bds_top)->bds_sym = (sym),  \
  280.     bds_top->bds_val = (sym)->s.s_dbind,  \
  281.     (sym)->s.s_dbind = (val))
  282. #define    bds_unwind1  \
  283.     ((bds_top->bds_sym)->s.s_dbind = bds_top->bds_val, --bds_top)
  284. typedef struct invocation_history {
  285.     object    ihs_function;
  286.     object    *ihs_base;
  287. } *ihs_ptr;
  288. struct invocation_history ihs_stack[];
  289. #define ihs_org        ihs_stack
  290. ihs_ptr ihs_limit;
  291. ihs_ptr ihs_top;
  292. #define    ihs_check  \
  293.     if (ihs_top >= ihs_limit)  \
  294.         ihs_overflow()
  295. #define ihs_push(function)  \
  296.     (++ihs_top)->ihs_function = (function);  \
  297.     ihs_top->ihs_base = vs_base
  298. #define ihs_pop()     (ihs_top--)
  299. enum fr_class {
  300.     FRS_CATCH,
  301.     FRS_CATCHALL,
  302.     FRS_PROTECT
  303. };
  304. struct frame {
  305.     jmp_buf        frs_jmpbuf;
  306.     object        *frs_lex;
  307.     bds_ptr        frs_bds_top;
  308.     enum fr_class    frs_class;
  309.     object        frs_val;
  310.     ihs_ptr        frs_ihs;
  311. };
  312. typedef struct frame *frame_ptr;
  313. #define    alloc_frame_id()    alloc_object(t_spice)
  314. struct frame frame_stack[];
  315. #define frs_org        frame_stack
  316. frame_ptr frs_limit;
  317. frame_ptr frs_top;
  318. #define frs_push(class, val)  \
  319.     if (++frs_top >= frs_limit)  \
  320.         frs_overflow();  \
  321.     frs_top->frs_lex = lex_env;\
  322.     frs_top->frs_bds_top = bds_top;  \
  323.     frs_top->frs_class = (class);  \
  324.     frs_top->frs_val = (val);  \
  325.     frs_top->frs_ihs = ihs_top;  \
  326.         setjmp(frs_top->frs_jmpbuf)
  327. #define frs_pop()    frs_top--
  328. bool nlj_active;
  329. frame_ptr nlj_fr;
  330. object nlj_tag;
  331. object *lex_env;
  332. object caar();
  333. object cadr();
  334. object cdar();
  335. object cddr();
  336. object caaar();
  337. object caadr();
  338. object cadar();
  339. object caddr();
  340. object cdaar();
  341. object cdadr();
  342. object cddar();
  343. object cdddr();
  344. object caaaar();
  345. object caaadr();
  346. object caadar();
  347. object caaddr();
  348. object cadaar();
  349. object cadadr();
  350. object caddar();
  351. object cadddr();
  352. object cdaaar();
  353. object cdaadr();
  354. object cdadar();
  355. object cdaddr();
  356. object cddaar();
  357. object cddadr();
  358. object cdddar();
  359. object cddddr();
  360. #define MMcons(a,d)    make_cons((a),(d))
  361. #define MMcar(x)    (x)->c.c_car
  362. #define MMcdr(x)    (x)->c.c_cdr
  363. #define CMPcar(x)    (x)->c.c_car
  364. #define CMPcdr(x)    (x)->c.c_cdr
  365. #define CMPcaar(x)    (x)->c.c_car->c.c_car
  366. #define CMPcadr(x)    (x)->c.c_cdr->c.c_car
  367. #define CMPcdar(x)    (x)->c.c_car->c.c_cdr
  368. #define CMPcddr(x)    (x)->c.c_cdr->c.c_cdr
  369. #define CMPcaaar(x)    (x)->c.c_car->c.c_car->c.c_car
  370. #define CMPcaadr(x)    (x)->c.c_cdr->c.c_car->c.c_car
  371. #define CMPcadar(x)    (x)->c.c_car->c.c_cdr->c.c_car
  372. #define CMPcaddr(x)    (x)->c.c_cdr->c.c_cdr->c.c_car
  373. #define CMPcdaar(x)    (x)->c.c_car->c.c_car->c.c_cdr
  374. #define CMPcdadr(x)    (x)->c.c_cdr->c.c_car->c.c_cdr
  375. #define CMPcddar(x)    (x)->c.c_car->c.c_cdr->c.c_cdr
  376. #define CMPcdddr(x)    (x)->c.c_cdr->c.c_cdr->c.c_cdr
  377. #define CMPcaaaar(x)    (x)->c.c_car->c.c_car->c.c_car->c.c_car
  378. #define CMPcaaadr(x)    (x)->c.c_cdr->c.c_car->c.c_car->c.c_car
  379. #define CMPcaadar(x)    (x)->c.c_car->c.c_cdr->c.c_car->c.c_car
  380. #define CMPcaaddr(x)    (x)->c.c_cdr->c.c_cdr->c.c_car->c.c_car
  381. #define CMPcadaar(x)    (x)->c.c_car->c.c_car->c.c_cdr->c.c_car
  382. #define CMPcadadr(x)    (x)->c.c_cdr->c.c_car->c.c_cdr->c.c_car
  383. #define CMPcaddar(x)    (x)->c.c_car->c.c_cdr->c.c_cdr->c.c_car
  384. #define CMPcadddr(x)    (x)->c.c_cdr->c.c_cdr->c.c_cdr->c.c_car
  385. #define CMPcdaaar(x)    (x)->c.c_car->c.c_car->c.c_car->c.c_cdr
  386. #define CMPcdaadr(x)    (x)->c.c_cdr->c.c_car->c.c_car->c.c_cdr
  387. #define CMPcdadar(x)    (x)->c.c_car->c.c_cdr->c.c_car->c.c_cdr
  388. #define CMPcdaddr(x)    (x)->c.c_cdr->c.c_cdr->c.c_car->c.c_cdr
  389. #define CMPcddaar(x)    (x)->c.c_car->c.c_car->c.c_cdr->c.c_cdr
  390. #define CMPcddadr(x)    (x)->c.c_cdr->c.c_car->c.c_cdr->c.c_cdr
  391. #define CMPcdddar(x)    (x)->c.c_car->c.c_cdr->c.c_cdr->c.c_cdr
  392. #define CMPcddddr(x)    (x)->c.c_cdr->c.c_cdr->c.c_cdr->c.c_cdr
  393. #define CMPfuncall    funcall
  394. #define    cclosure_call    funcall
  395. object simple_lispcall();
  396. object simple_lispcall_no_event();
  397. object simple_symlispcall();
  398. object simple_symlispcall_no_event();
  399. object CMPtemp;
  400. object CMPtemp1;
  401. object CMPtemp2;
  402. object CMPtemp3;
  403. #define    Cnil    ((object)&Cnil_body)
  404. #define    Ct    ((object)&Ct_body)
  405. struct symbol Cnil_body, Ct_body;
  406. object MF();
  407. object MM();
  408. object Scons;
  409. object siSfunction_documentation;
  410. object siSvariable_documentation;
  411. object siSpretty_print_format;
  412. object Slist;
  413. object keyword_package;
  414. object alloc_object();
  415. object car();
  416. object cdr();
  417. object list();
  418. object listA();
  419. object coerce_to_string();
  420. object elt();
  421. object elt_set();
  422. frame_ptr frs_sch();
  423. frame_ptr frs_sch_catch();
  424. object make_cclosure();
  425. object nth();
  426. object nthcdr();
  427. object make_cons();
  428. object append();
  429. object nconc();
  430. object reverse();
  431. object nreverse();
  432. object number_expt();
  433. object number_minus();
  434. object number_negate();
  435. object number_plus();
  436. object number_times();
  437. object one_minus();
  438. object one_plus();
  439. object get();
  440. object getf();
  441. object putprop();
  442. object remprop();
  443. object string_to_object();
  444. object symbol_function();
  445. object symbol_value();
  446. object make_fixnum();
  447. object make_shortfloat();
  448. object make_longfloat();
  449. object structure_ref();
  450. object structure_set();
  451. object princ();
  452. object prin1();
  453. object print();
  454. object terpri();
  455. object aref();
  456. object aset();
  457. object aref1();
  458. object aset1();
  459. char object_to_char();
  460. int object_to_int();
  461. float object_to_float();
  462. double object_to_double();
  463. int FIXtemp;
  464. #define    CMPmake_fixnum(x) \
  465. ((((FIXtemp=(x))+1024)&-2048)==0?small_fixnum(FIXtemp):make_fixnum(FIXtemp))
  466. #define Creturn(v) return((vs_top=vs,(v)))
  467. #define Cexit return((vs_top=vs,0))
  468. double sin(), cos(), tan();
  469.